home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / win / pascal / frame3.exe / FRAMEDLG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-03-21  |  11.4 KB  |  415 lines
  1.  
  2. {$A+}   { Align data }
  3. {$B-}   { Boolean evaluation }
  4. {$E+}   { 80x87 emulator }
  5. {$F-}   { Force FAR calls }
  6. {$G+}   { 80286 code }
  7. {$I-}   { I/O checking }
  8. {$K-}   { Smart Callbacks }
  9. {$N-}   { 80x87 code }
  10. {$O-}   { Overlays allowed }
  11. {$P-}   { Open parameters }
  12. {$T-}   { Typed pointers }
  13. {$V-}   { String VAR checking }
  14. {$W-}   { Windows stack frame for real mode }
  15. {$X+}   { Extended syntax }
  16.  
  17. {$IFDEF DEBUG}
  18.     {$D+}   { Debug information }
  19.     {$L+}   { Local symbols }
  20.     {$Q+}   { Overflow checking }
  21.     {$R+}   { Range checking }
  22.     {$S+}   { Stack checking }
  23.     {$Y+}   { Symbol reference information }
  24. {$ELSE}
  25.     {$D-}   { Debug information }
  26.     {$L-}   { Local symbols }
  27.     {$Q-}   { Overflow checking }
  28.     {$R-}   { Range checking }
  29.     {$S-}   { Stack checking }
  30.     {$Y-}   { Symbol reference information }
  31. {$ENDIF}
  32.  
  33. {$C Moveable Demandload Discardable} { Code Segment attributes }
  34.  
  35. UNIT FrameDlg;
  36.  
  37. {
  38.   Copyright (c) 1992 by Olaf He▀ (Hess), Munich, Germany.
  39.  
  40.   Please feel free to use this code in your own programs.
  41.   If you make $$$ with it ->> You have my ID!
  42.   If you find any bugs or do any changes to the source code that you find
  43.   generally useful please send me a message to my CompuServe account
  44.   100 031, 35 36.
  45.  
  46.   Thanks.
  47. }
  48.  
  49. {$R FRAMEDLG.RES}
  50.  
  51. INTERFACE
  52.  
  53. USES WinProcs, WinTypes, OWindows, ODialogs;
  54.  
  55. CONST
  56.     rgbLightGray = $C0C0C0; { Light gray }
  57.  
  58. TYPE
  59.     PFrameStatic = ^TFrameStatic;
  60.     TFrameStatic = OBJECT (TStatic)
  61.       PRIVATE
  62.         PROCEDURE SetupWindow; VIRTUAL;
  63.  
  64.         PROCEDURE WMPaint (VAR Msg: TMessage);
  65.             VIRTUAL wm_First + wm_Paint;
  66.  
  67.         PROCEDURE PaintBkGnd (CONST hThisDC: hDC);
  68.         PROCEDURE PaintFrame; VIRTUAL;
  69.     END; { TFrameStatic }
  70.  
  71.  
  72.     PStaticUp = ^TStaticUp;
  73.     TStaticUp = OBJECT (TFrameStatic)
  74.         PROCEDURE PaintFrame; VIRTUAL;
  75.     END; { TStaticUp }
  76.  
  77.     PStaticDown = ^TStaticDown;
  78.     TStaticDown = OBJECT (TFrameStatic)
  79.         PROCEDURE PaintFrame; VIRTUAL;
  80.     END; { TStaticDown }
  81.  
  82.     PFrameDown = ^TFrameDown;
  83.     TFrameDown = OBJECT (TStaticDown)
  84.         CONSTRUCTOR InitResource (AParent: PWindowsObject;
  85.                                   ResourceId: Integer);
  86.         PROCEDURE SetupWindow; VIRTUAL;
  87.     END; { TFrameDown }
  88.  
  89.     PFrameUp = ^TFrameUp;
  90.     TFrameUp = OBJECT (TStaticUp)
  91.         CONSTRUCTOR InitResource (AParent: PWindowsObject;
  92.                                   ResourceId: Integer);
  93.         PROCEDURE SetupWindow; VIRTUAL;
  94.     END; { TFrameUp }
  95.  
  96.     PSteelDlgWnd = ^TSteelDlgWnd;
  97.     TSteelDlgWnd = OBJECT (TDlgWindow)
  98.         PROCEDURE WMCtlColor (VAR Msg: TMessage);
  99.             VIRTUAL wm_First + wm_CtlColor;
  100.     END; { TSteelDlgWnd }
  101.  
  102.     PSteelDialog = ^TSteelDialog;
  103.     TSteelDialog = OBJECT (TDialog)
  104.         PROCEDURE WMCtlColor (VAR Msg: TMessage);
  105.             VIRTUAL wm_First + wm_CtlColor;
  106.     END; { TSteelDialog }
  107.  
  108.  
  109. VAR
  110.     hBackgroundBrush : hBrush; { Background brush }
  111.     fDoColors : Boolean; { TRUE if graphics card support more than 8 colors }
  112.  
  113. IMPLEMENTATION
  114.  
  115. VAR
  116.     OldExitProc : Pointer;
  117.  
  118. (* ---- *)
  119.  
  120. PROCEDURE TFrameStatic.SetupWindow;
  121. { Set the window style attributes }
  122.  
  123. VAR
  124.     lStyle : LongInt;
  125.  
  126. BEGIN
  127.     INHERITED SetupWindow; { Call ancestor }
  128.  
  129.     { Get and set the style bits }
  130.     lStyle := GetWindowLong (hWindow, gwl_Style);
  131.     lStyle := lStyle AND NOT ws_Border;
  132.     SetWindowLong (hWindow, gwl_Style, lStyle);
  133. END; { TFrameStatic.SetupWindow }
  134.  
  135. (* ---- *)
  136.  
  137. PROCEDURE TFrameStatic.WMPaint (VAR Msg: TMessage);
  138. { Paint the static control }
  139.  
  140. BEGIN
  141.     INHERITED WMPaint (Msg); { Call ancestor }
  142.     PaintFrame; { Paint borders }
  143. END; { TFrameStatic.WMPaint }
  144.  
  145. (* ---- *)
  146.  
  147. PROCEDURE TFrameStatic.PaintBkGnd (CONST hThisDC: hDC);
  148. { Paint a gray background }
  149.  
  150. VAR
  151.     hOldBrush : hBrush;
  152.     pToRect : PRect;
  153.  
  154. BEGIN
  155.     New (pToRect);
  156.  
  157.     GetClientRect (hWindow, pToRect^); { Get frame size }
  158.  
  159.     { Get brush for drawing }
  160.     hOldBrush := SelectObject (hThisDC, GetStockObject (ltGray_Brush));
  161.  
  162.     WITH pToRect^ DO { Paint the gray background }
  163.         Rectangle (hThisDC, Left, Top, Right, Bottom);
  164.  
  165.     SelectObject (hThisDC, hOldBrush);
  166.  
  167.     Dispose (pToRect);
  168. END; { TFrameStatic.PaintBkGrd }
  169.  
  170. (* ---- *)
  171.  
  172. PROCEDURE TFrameStatic.PaintFrame;
  173. { Just a placeholder }
  174.  
  175. BEGIN
  176. END; { TFrameStatic.PaintFrame }
  177.  
  178. (* ---- *)
  179.  
  180. PROCEDURE TStaticUp.PaintFrame;
  181. { Paint a raised border }
  182.  
  183. VAR
  184.     hWindowDC : hDC;
  185.     hOldBrush : hBrush;
  186.     rc : TRect;
  187.     x, y : Integer;
  188.  
  189. BEGIN
  190.     GetClientRect (hWindow, rc); { Get size }
  191.     { Coordinates of the lower right corner }
  192.     x := rc.Right;
  193.     y := rc.Bottom;
  194.     hWindowDC := GetDC (hWindow);
  195.  
  196.     IF (NOT fDoColors) THEN
  197.     BEGIN { Not enough colors ->> paint in black }
  198.         hOldBrush := SelectObject (hWindowDC, GetStockObject (BLACK_BRUSH));
  199.         PatBlt (hWindowDC, 0, 0, x, 1, PATCOPY); { Top line }
  200.         PatBlt (hWindowDC, 0, 0, 1, y, PATCOPY); { Left line }
  201.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Bottom line }
  202.         PatBlt (hWindowDC, x - 1, 1, 1, y - 1, PATCOPY); { Right line }
  203.     END { if }
  204.     ELSE
  205.     BEGIN
  206.         { Color of the top and left line is white }
  207.         hOldBrush := SelectObject (hWindowDC,
  208.                                    GetStockObject (WHITE_BRUSH));
  209.  
  210.         PatBlt (hWindowDC, -1, -1, x + 2, 2, PATCOPY); { Paint top line }
  211.         PatBlt (hWindowDC, -1, 1, 2, y, PATCOPY); { Paint left line }
  212.  
  213.         { Color of the bottom and right line is gray }
  214.         SelectObject (hWindowDC, GetStockObject (GRAY_BRUSH));
  215.  
  216.         { Paint bottom line }
  217.         PatBlt (hWindowDC, 1, y - 1, x, 1, PATCOPY); { Inside }
  218.         PatBlt (hWindowDC, 0, y, x + 1, 1, PATCOPY); { Middle }
  219.         PatBlt (hWindowDC, -1, y + 1, x + 2, 1, PATCOPY); { Outside }
  220.  
  221.         { Paint right line }
  222.         PatBlt (hWindowDC, x - 2, 1, 1, y - 2, PATCOPY); { Inside }
  223.         PatBlt (hWindowDC, x - 1, 0, 1, y - 1, PATCOPY); { Middle }
  224.         PatBlt (hWindowDC, x, -1, 1, y, PATCOPY); { Outside }
  225.     END; { else }
  226.  
  227.     SelectObject (hWindowDC, hOldBrush);
  228.     ReleaseDC (hWindow, hWindowDC);
  229. END; { TStaticUp.PaintFrame }
  230.  
  231. (* ---- *)
  232.  
  233. PROCEDURE TStaticDown.PaintFrame;
  234. { Paint a recessed static control }
  235.  
  236. VAR
  237.     hWindowDC : hDC;
  238.     hOldBrush : hBrush;
  239.     rc : TRect;
  240.     x, y : Integer;
  241.  
  242. BEGIN
  243.     GetClientRect (hWindow, rc); { Get size }
  244.     { Coordinates of the lower right corner }
  245.     x := rc.Right;
  246.     y := rc.Bottom;
  247.     hWindowDC := GetDC (hWindow);
  248.  
  249.     IF (NOT fDoColors) THEN
  250.     BEGIN { Not enough colors ->> paint in black }
  251.         hOldBrush := SelectObject (hWindowDC, GetStockObject (BLACK_BRUSH));
  252.         PatBlt (hWindowDC, 0, 0, x, 1, PATCOPY); { Top line }
  253.         PatBlt (hWindowDC, 0, 0, 1, y, PATCOPY); { Left line }
  254.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Bottom line }
  255.         PatBlt (hWindowDC, x - 1, 1, 1, y - 1, PATCOPY); { Right line }
  256.     END { if }
  257.     ELSE
  258.     BEGIN
  259.         { Color of the top and left line is gray }
  260.         hOldBrush := SelectObject (hWindowDC,
  261.                                    GetStockObject (GRAY_BRUSH));
  262.  
  263.         PatBlt (hWindowDC, -1, -1, x + 1, 3, PATCOPY); { Paint top line }
  264.         PatBlt (hWindowDC, -1, 0, 3, y, PATCOPY); { Paint left line }
  265.  
  266.         { Color of the bottom and right line is white }
  267.         SelectObject (hWindowDC, GetStockObject (WHITE_BRUSH));
  268.  
  269.         { Paint bottom line }
  270.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Inside }
  271.         PatBlt (hWindowDC, 0, y, x - 1, 1, PATCOPY); { Outside }
  272.  
  273.         { Paint right line }
  274.         PatBlt (hWindowDC, x - 1, 1, 1, y, PATCOPY); { Inside }
  275.         PatBlt (hWindowDC, x, 0, 1, y + 1, PATCOPY); { Outside }
  276.     END; { else }
  277.  
  278.     SelectObject (hWindowDC, hOldBrush);
  279.     ReleaseDC (hWindow, hWindowDC);
  280. END; { TStaticDown.PaintFrame }
  281.  
  282. (* ---- *)
  283.  
  284. CONSTRUCTOR TFrameDown.InitResource (AParent: PWindowsObject;
  285.                                      ResourceId: Integer);
  286.  
  287. BEGIN
  288.     { Call ancestor, set text length to 0 }
  289.     INHERITED InitResource (AParent, ResourceId, 0);
  290.  
  291.     DisableTransfer; { Disable the transfer mechanism for this control! }
  292. END; { TFrameDown.InitResource }
  293.  
  294. (* ---- *)
  295.  
  296. PROCEDURE TFrameDown.SetupWindow;
  297.  
  298. VAR
  299.     lStyle : LongInt;
  300.  
  301. BEGIN
  302.     INHERITED SetupWindow;
  303.  
  304.     { Get and set the style bits }
  305.     lStyle := GetWindowLong (hWindow, gwl_Style);
  306.     lStyle := lStyle AND NOT ss_BlackRect;
  307.     lStyle := lStyle OR ss_Left;
  308.     SetWindowLong (hWindow, gwl_Style, lStyle);
  309. END; { TFrameDown.SetupWindow }
  310.  
  311. (* ---- *)
  312.  
  313. CONSTRUCTOR TFrameUp.InitResource (AParent: PWindowsObject;
  314.                                    ResourceId: Integer);
  315.  
  316. BEGIN
  317.     { Call ancestor, set text length to 0 }
  318.     INHERITED InitResource (AParent, ResourceId, 0);
  319.  
  320.     DisableTransfer; { Disable the transfer mechanism for this control! }
  321. END; { TFrameUp.InitResource }
  322.  
  323. (* ---- *)
  324.  
  325. PROCEDURE TFrameUp.SetupWindow;
  326.  
  327. VAR
  328.     lStyle : LongInt;
  329.  
  330. BEGIN
  331.     INHERITED SetupWindow;
  332.  
  333.     { Get and set the style bits }
  334.     lStyle := GetWindowLong (hWindow, gwl_Style);
  335.     lStyle := lStyle AND NOT ss_BlackRect;
  336.     lStyle := lStyle OR ss_Left;
  337.     SetWindowLong (hWindow, gwl_Style, lStyle);
  338. END; { TFrameUp.SetupWindow }
  339.  
  340. (* ---- *)
  341.  
  342. PROCEDURE TSteelDlgWnd.WMCtlColor (VAR Msg: TMessage);
  343. { Set the background color for the dialog window + it's controls }
  344.  
  345. BEGIN
  346.     DefWndProc (Msg); { Call standard proc first }
  347.  
  348.     WITH Msg DO
  349.         IF (NOT fDoColors) THEN Exit { Not enough colors }
  350.         ELSE
  351.         BEGIN
  352.             SetBkColor (wParam, rgbLightGray); { Set backround color }
  353.  
  354.             IF (lParamHi = CtlColor_Dlg) THEN
  355.                 { Background brush for dialog window }
  356.                 Result := hBackgroundBrush
  357.             ELSE Result := GetStockObject (LtGray_Brush); { Gray in gray }
  358.         END; { else }
  359. END; { TSteelDlgWnd.WMCtlColor }
  360.  
  361. (* ---- *)
  362.  
  363. PROCEDURE TSteelDialog.WMCtlColor (VAR Msg: TMessage);
  364. { Set the background color for the dialog window + it's controls }
  365.  
  366. BEGIN
  367.     DefWndProc (Msg); { Call standard proc first }
  368.  
  369.     WITH Msg DO
  370.         IF (NOT fDoColors) THEN Exit { Not enough colors }
  371.         ELSE
  372.         BEGIN
  373.             SetBkColor (wParam, rgbLightGray); { Set background color }
  374.  
  375.             IF (lParamHi = CtlColor_Dlg) THEN
  376.                 { Background brush for dialog window }
  377.                 Result := hBackgroundBrush
  378.             ELSE Result := GetStockObject (LtGray_Brush); { Gray in gray }
  379.         END; { else }
  380. END; { TSteelDialog.WMCtlColor }
  381.  
  382. (* ---- *)
  383.  
  384. PROCEDURE NewExitProc; FAR;
  385. { Release background brush }
  386.  
  387. BEGIN
  388.     DeleteObject (hBackGroundBrush); { Delete brush }
  389.  
  390.     { Call old EXIT-proc }
  391.     ExitProc := OldExitProc;
  392. END; { NewExitProc }
  393.  
  394. (* ---- *)
  395.  
  396. VAR
  397.     hBackgroundBitmap : hBitmap;
  398.     hWindowsDC : hDC;
  399.  
  400. BEGIN { FrameDlg }
  401.     { Set new EXIT-proc }
  402.     OldExitProc := ExitProc;
  403.     ExitProc := @NewExitProc;
  404.  
  405.     { Can the graphics card display more than 8 colors }
  406.     hWindowsDC := GetDC (0);
  407.     fDoColors := GetDeviceCaps (hWindowsDC, NumColors) >= 8; { Get colors }
  408.     ReleaseDC (0, hWindowsDC);
  409.  
  410.     { Load new background brush }
  411.     hBackGroundBitmap := LoadBitmap (hInstance, 'MY_BRUSH');
  412.     hBackGroundBrush := CreatePatternBrush (hBackGroundBitmap);
  413.     DeleteObject (hBackGroundBitmap);
  414. END. { FrameDlg }
  415.